home *** CD-ROM | disk | FTP | other *** search
/ World of Video / World of Video.iso / gfxprograms / viewers / pcxaga / showpcx.pas < prev   
Pascal/Delphi Source File  |  1995-02-13  |  8KB  |  310 lines
  1. Program AmigaPCX;
  2. uses Exec,Graphics,Intuition,AmigaDos,Dos;
  3. type arr=array[0..3600] of byte;
  4.      st=string;
  5. var    l,f,clas,kod,le,lo,o,hlp: longint;
  6.     w,bl,mx,my,x,y: word;
  7.     b,bb,col,col1,bpln,pb: byte;
  8.     MyScreen: tNewScreen;
  9.     MyWindow: tNewWindow;
  10.     MyBitMap: tBitmap;
  11.     Scr: pScreen;
  12.     STitle, WTitle, FontName, name, stng: string;
  13.     Win: pWindow;
  14.     tFont: tTextAttr;
  15.     pt: pointer;
  16.     p: ^arr;
  17.     ps: ^st;
  18.     pim: pintuimessage;
  19.     out: boolean;
  20.     ch:char;
  21.     pf:^tfileinfoblock;
  22.     
  23. label Crash, Help;
  24.  
  25. procedure OpenLibraries;
  26. begin
  27.   IntuitionBase := pIntuitionBase(OpenLibrary('intuition.library',0));
  28.   if IntuitionBase = NIL then writeln( 'Intuition.library could not be opened');
  29.  
  30.   GfxBase := pGfxBase(OpenLibrary('graphics.library',0));
  31.   if GfxBase = NIL then writeln( 'Graphics.library could not be opened');
  32. end;
  33.  
  34. procedure OpenScr;
  35. begin
  36.   FontName:='topaz.font'#0;
  37.    with tFont do begin
  38.     ta_Name:=@FontName[1];
  39.     ta_YSize:=8;
  40.     ta_Style:= FSF_EXTENDED;
  41.     ta_Flags:=Fpf_ROMFONT
  42.    end;
  43.  
  44.   STitle:='PCXShow'#0;
  45.   With MyScreen do begin
  46.     LeftEdge   := 0;                
  47.     TopEdge    := 0;
  48.     Width      := 319;
  49.     Height     := 255;
  50.     Depth      := bpln;                
  51.     DetailPen  := 2;           { Color for details }
  52.     BlockPen   := 5;            { and for blocks }
  53.     ViewModes  := 0;            
  54.     Type_      := CUSTOMSCREEN or SPRITES;
  55.     Font       := @tFONT;         { Use the normal Topaz font }
  56.     DefaultTitle := @STitle[1];
  57.     Gadgets      := NIL;            { No gadgets }
  58.     CustomBitMap := NIL             { No bitmap }
  59.  end;
  60.   
  61.   Scr:=OpenScreen(@MyScreen);
  62.  if scr=nil then writeln('Can''t open screen');
  63. end;
  64.  
  65. procedure OpenWin(Tit: string; var pW: pWindow; maxx,maxy: word);
  66. begin
  67.   with MyWindow do begin
  68.     LeftEdge      := 0;
  69.     TopEdge       := 0;
  70.     Width         := 319;
  71.     Height        := 255;
  72.     DetailPen     := 3;
  73.     BlockPen      := 1;
  74.     if tit='' then Title:=nil else Title:=@tit;
  75.     Flags         := SMART_REFRESH or     { Save window in RAM }
  76.                      ACTIVATE or          { Activate it }
  77.                      NOCAREREFRESH or
  78.                      BORDERLESS or
  79.                      SUPER_BITMAP or
  80.                      RMBTRAP or
  81.                      REPORTMOUSE_ ;
  82.     IDCMPFlags    := CloseWindow_ or MouseButtons or MouseMove;
  83.     Type_         := CUSTOMSCREEN;        { Put window in custom screen }
  84.     FirstGadget   := NIL;                 { No gadgets attached }
  85.     CheckMark     := NIL;                 { Same checkmark as usual }
  86.     Screen        := Scr;          { Use our own custom screen }
  87.     BitMap        := @MyBitMap;                 { No bitmap }
  88.     MinWidth      := 300;               { Dummies as we can't resize }
  89.     MinHeight     := 200;              { this window }
  90.     MaxWidth      := 320;
  91.     MaxHeight     := 256
  92.   end;
  93.  with MyBitMap do begin
  94.     BytesperRow:= maxx div 8;
  95.     Rows:=maxy;
  96.     Depth:=bpln;
  97.     for b:=0 to bpln-1 do Planes[b]:=AllocRaster(maxx,maxy); 
  98.   end;
  99.   InitBitmap(@MyBitMap,bpln,maxx,maxy);
  100.   
  101.   pW := OpenWindow(@MyWindow);
  102.   if pW = NIL then WRITELN('CANNOT OPEN WINDOW');
  103. end; 
  104.  
  105. procedure Header;
  106. var hd:arr;
  107.     minx,miny: word;
  108. begin
  109.  Getmem(pt,1300);GetMem(p,1200);
  110.  out:=false;
  111.  lo:=lock(name,$F);
  112.  if examine(lo,pt) then writeln('OK') else begin writeln('NOK - Chyba pri inicializaci. »»»>>> Bye Bye');halt;end;
  113.  pf:=pt;le:=pf^.fib_size;
  114.  
  115.  getmem(p,1264);
  116.  f:=Open(name,mode_oldfile);
  117.  l:=read_(f,p,128);
  118.  hd:=p^;
  119.  if hd[0]<>10 then begin writeln('Neni PCX obrazek!');out:=true;end else writeln('Obrazek:',name);
  120.  writeln('Velikost:',le,' b');
  121.  if hd[2]=1 then writeln('RLE kodovani') else writeln('Bez kodovani');
  122.  writeln('Bitu na pixel:',hd[3]);
  123.  mx:=256*hd[9]+hd[8]+1;my:=256*hd[11]+hd[10]+1;
  124.  minx:=256*hd[5]+hd[4];miny:=256*hd[7]+hd[6];
  125.  writeln('Min:',minx,'x',miny);
  126.  mx:=256*hd[9]+hd[8]+1;my:=256*hd[11]+hd[10]+1;
  127.  writeln('Max:',mx,'x',my);
  128.  if (minx>1) or (miny>1) then begin mx:=mx-minx;my:=my-miny;end;
  129.  
  130.  writeln('Rozmery:',mx,'x',my);
  131.  writeln('Bitovych rovin:',hd[65]);
  132.  bl:=256*hd[67]+hd[66];
  133.  writeln('Bytu na linku:',bl);
  134.  writeln(#10'* Stiskni RETURN *');
  135.  readln;
  136. end;
  137.  
  138. procedure ShowPCX(RP:pRastPort; po:pointer; x1,y1,x2,y2:word);
  139. var g,gg:byte;
  140.     dx,dy:word;
  141.     n:longint;
  142. begin            {ShowPCX by Petr Ocko © 1994  All rights reserved.}
  143. { ScreentoFront(Scr);}    {Contact: XOCKP01@jms.vse.cz}
  144.              {or}
  145.  n:=0;dy:=y1;        {Sv. Cecha 1130}
  146.  asm            {Bohumin 1}
  147.   movea.l po,a4        {Czech Republic}
  148.  end;
  149.  repeat
  150.   dx:=x1;
  151.   repeat
  152.    asm
  153.     move.b (a4)+,g
  154.    end;
  155.    if g and $c0=$c0 then begin
  156.     asm
  157.      move.b (a4)+,gg
  158.     end;
  159.     SetAPen(RP,gg);
  160.     Move_(RP,dx,dy);
  161.     dx:=dx+(g and $3f);
  162.     Draw(RP,dx,dy);
  163.    end else
  164.     begin
  165.      SetApen(RP,g);
  166.      Move_(RP,dx,dy);
  167.      dx:=dx+1;
  168.      Draw(RP,dx,dy);
  169.     end;
  170.   until dx>=x2+1;
  171.   dy:=dy+1;
  172.  until dy=y2;
  173.  {Permit;}
  174. end;
  175.  
  176. procedure Paleta;
  177. var h:arr;
  178.     p1,p2,p3,p4:longint;
  179.     psc:pointer;
  180. begin
  181.  if bpln=8 then pb:=255 else pb:=31;
  182.  ScreenToFront(scr);
  183.  pt:=AllocMem(1000,memf_chip);
  184.  l:=seek_(f,le-256*3,$ffffffff);
  185.  l:=read_(f,pt,3*256);
  186.  psc:=@scr^.Viewport;
  187.  asm
  188.    move.l a4,p4
  189.    movea.l pt,a4
  190.    clr.l d0
  191.    clr.l d1
  192.    clr.l d2
  193.    clr.l d3
  194.    clr.l d7
  195.    moveq #0,d7
  196. @r:move.b (a4)+,d1
  197.    lsr.b #4,d1
  198.    move.b (a4)+,d2
  199.    lsr.b #4,d2
  200.    move.b (a4)+,d3
  201.    lsr.b #4,d3
  202.    move.l a0,p1
  203.    movea.l a6,a5
  204.    movea.l psc,a0
  205.    move.l d7,d0
  206.    movea.l GfxBase,a6
  207.    jsr -$120(a6)
  208.    movea.l a5,a6
  209.    move.l p1,a0
  210.    addq.b #1,d7
  211.    cmp.b pb,d7
  212.    bne @r
  213.   move.l p4,a4
  214.  end;
  215.  l:=seek_(f,128,$ffffffff);
  216.  FreeMem_(pt,1000);
  217. end; 
  218.  
  219. procedure DataRead;
  220. begin
  221.  Paleta;
  222.  for b:=0 to pb do begin
  223.      SetAPen(Win^.RPort,b);
  224.      RectFill(Win^.RPort,b*2,0,b*2+2,5);
  225.  end;
  226.  pt:=AllocMem(le-767,memf_chip);        {alokace pameti pro buffer}
  227.  if pt=nil then begin writeln('Nedostatek pameti!');out:=true;exit;end;
  228.  l:=read_(f,pt,le-768);
  229.  out:=WBenchToFront;
  230.  out:=false;
  231.  
  232.  Forbid;
  233.  ShowPCX(Win^.RPort,pt,0,0,mx-1,my-1);
  234.  writeln(#7);
  235.  unlock(lo);
  236. end; 
  237.  
  238. begin
  239.  OpenLibraries;
  240.  GetMem(pt,1200);getmem(ps,128);
  241.  if ParamCount>0 then begin for bb:=1 to paramcount do name:=name+ParamStr(bb);end else begin
  242.       o:=Open('CON:10/100/480/36/Zadej jmeno PCX obrazku:',mode_oldfile);
  243.       stng:='ShowPCX v2.1 * Usage: ShowPCX [filename] [OCS] [?]'#10#0;
  244.       ps:=@stng[1];
  245.       l:=Write_(o,ps,52);
  246.      l:=Read_(o,ps,127);
  247.      bb:=l;
  248.      asm 
  249.       move.l ps,a4
  250.       subq #1,a4 
  251.       move.b bb,(a4)
  252.       sub.b #1,(a4)
  253.       move.l a4,ps        {prevadeni AMIGA stringu do pascalovskeho}
  254.      end;
  255.      name:=ps^;
  256.      Close_(o);
  257.  end;
  258.  WriteLn('PCXShow v2.1 © 1994 by Petr Ocko'#10'Contact: Sv. Cecha 1130'#10'  735 81 Bohumin-1'#10'  Czech Republic');
  259.  WriteLn('E-Mail: XOCKP01@jms.vse.cz');
  260.  if name[1]='?' then begin writeln('Usage: ShowPCX [?] [[filename] [OCS]]'#10' OCS - shows picture in 5 bplanes screen');
  261.              Readln;
  262.              Goto help;
  263.              end;
  264.  bpln:=8;
  265.  for b:=1 to length(name) do begin
  266.      if copy(name,b,3)='OCS' then bpln:=5;
  267.      end;
  268.  if bpln=5 then begin 
  269.      if copy(name,1,3)='OCS' then name:=copy(name,4,length(name)-3) else
  270.          name:=copy(name,1,length(name)-3);
  271.      end;
  272.  Header;if out then Exit;
  273.  OpenScr;
  274.  OpenWin('',Win,mx,my);
  275.  ScreentoBack(Scr);
  276.  ClearScreen(Win^.Rport);
  277.  ShowTitle(Scr,false);
  278.  WriteLn('PCXShow v2.1 © 1994 by Petr Ocko'#10);
  279.  WriteLn(#10'Decrunching ',name,' ...');
  280.   
  281.  DataRead;if out then goto crash;
  282.  
  283.  ScreenToFront(Scr);
  284.  FreeSprite(0);out:=false;
  285.  With Win^ do begin
  286.  repeat
  287.   l:=wait(Bitmask(Win^.userport^.mp_sigbit));
  288.   pim:=PINTUIMESSAGE(getmsg(userport));
  289.   while pim<>nil do begin
  290.    FreeSprite(0);
  291.    clas:=pim^.class;
  292.    kod:=pim^.code;
  293.    replymsg(pmessage(pim));
  294.    if clas=RIGHTHIT then out:=true;
  295.    pim:=pIntuiMessage(getmsg(userport));
  296.   end;
  297.  until out; 
  298.  Permit;
  299.  end;
  300. Crash:
  301.  CloseWindow(Win);
  302.  For b:=0 to bpln-1 do FreeRaster(MyBitmap.Planes[b],mx,my); 
  303.  
  304.  Close_(f);
  305.  CloseScreen(Scr);
  306.  closelibrary(pLibrary(GfxBase));
  307.  closelibrary(pLibrary(IntuitionBase));
  308. FreeMem_(pt,le-768);
  309. help:
  310. end.